Pensieve Header: The degree growth rate?

βSimplify= (# // Together // ExpandDenominator // ExpandNumerator)&;
SetAttributes[βCollect, Listable];
βCollect[B[ω_, μ_]] := B[
βSimplify[ω],
Collect[μ, _h, Collect[#, _t, βSimplify]&]
];
(* "L" for "Labels" *)
hL[β_] := Union[Cases[β, h[s_] :> s, Infinity]];
tL[β_] := Union[Cases[β, t[s_]|(Subscript[T, s_]) :> s, Infinity]];
dL[β_] := Union[hL[β], tL[β]];
SetAttributes[βForm, Listable];
βForm[B[ω_, μ_]] := Module[
{tails, heads, mat},
tails = tL[B[ω, μ]]; heads = hL[B[ω, μ]];
mat = Outer[βSimplify[Coefficient[μ, h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat], Prepend[h /@ heads, ω]];
MatrixForm[mat]
];

R[x_, y_] := B[1, ((Subscript[T, x])-1)t[x]h[y]];
Rinv[x_, y_] := B[1, (1/(Subscript[T, x])-1)t[x]h[y]];
tm[x_, y_, z_][β_] := β /. {t[x]->t[z], t[y]->t[z], (Subscript[T, x])->(Subscript[T, z]), (Subscript[T, y])->(Subscript[T, z])};
hm[x_, y_, z_][B[ω_, μ_]] := Module[
{γx= D[μ, h[x]], γy=D[μ, h[y]], M=μ /. h[x]|h[y] -> 0},
B[ω, M+h[z](γx+γy+(γx /. t[i_] :> 1)γy)] // βCollect
];
swap[x_,y_][B[ω_, μ_]] := Module[
{α, β, γ, δ, ϵ},
α = Coefficient[μ, h[x]t[y]];
β = D[μ, t[y]] /. h[x] -> 0;
γ = D[μ, h[x]] /. t[y] -> 0;
δ = μ /. h[x]|t[y] -> 0;
ϵ = 1+α;
B[ω*ϵ, Plus[
α(1+(γ /. t[i_] :> 1)/ϵ)h[x]t[y],
β(1+(γ /. t[i_] :> 1)/ϵ)t[y],
γ/ϵ h[x],
δ-(1/ϵ) γ*β
]] // βCollect
];
gm[x_,y_,z_][β_] := β // swap[y,x] // hm[x,y,z] // tm[x,y,z];
B /: B[ω1_, μ1_]B[ω2_, μ2_] := B[ω1*ω2, μ1+μ2];

n=5;
Flatten[{
βForm[β= B[1,Sum[g Random[]t[i]h[j], {i,n}, {j,n}]]],
Table[
{
βForm[β= β // gm[1,k,1]],
Cases[β, g^k_.:>k, Infinity] // Max
},
{k,2,n}
]
}] // ColumnForm